-- ant.hs -- Eric Rollins 2006 {- Written for the Glasgow Haskell Compiler, http://www.haskell.org/ghc/ This program generates a random array of distances between cities, then uses Ant Colony Optimization to find a short path traversing all the cities -- the Travelling Salesman Problem. In this version of Ant Colony Optimization each ant starts in a random city. Paths are randomly chosed with probability inversely proportional to to the distance to the next city. At the end of its travel the ant updates the pheromone matrix with its path if this path is the shortest one yet found. The probability of later ants taking a path is increased by the pheromone value on that path. Pheromone values evaporate (decrease) over time. In this impementation weights between cities actually represent (maxDistance - dist), so we are trying to maximize the score. Usage: ant seed iterations seed seed for random number generator (1,2,3...). This seed controls the city distance array. Parallel evalations have their seed values fixed (1,2) so each will produce a different result. iterations number of ants to be run. The following should be parameters, but are constants for now. boost pheromone boost for best path. 5 appears good. 0 disables pheromones, providing random search. cities number of cities. (number of threads is controlled by +RTS -N# parameter) This program tests two different techniques for parallelism available in GHC. 'parallelBestPath' explicitly sparks new threads using 'seq' and 'par' functions. 'parallelBestPathStrategy' uses the 'parMap' function to automatically apply a function to all list elements in parallel. -} import Array import Random import Data.IntSet as Set import System.Environment -- defines 'par', 'seq' import Control.Parallel -- defines parMap import Control.Parallel.Strategies --seed :: Int --seed = 1 boost :: Int boost = 5 --iter :: Int --iter = 200 numCities :: Int numCities = 22 -- Infinite list of random numbers. randList :: Double -> Int -> [Double] randList upperBound lSeed = randomRs (1.0, upperBound) (mkStdGen lSeed) -- Matrix is square two dimensional array. matrix :: Int -> Array (Int,Int) Double matrix n = array ((0,0),(n-1,n-1)) [((i,j),0.0) | i<-[0..n-1], j<-[0..n-1]] indicesList :: Int -> [(Int,Int)] indicesList n = [(i,j) | i <- [0..n-1], j <- [0..n-1]] randomMatrix :: Int -> Double -> Int -> Array (Int,Int) Double randomMatrix n upperBound lSeed = array ((0,0),(n-1,n-1)) (zip (indicesList n) (randList upperBound lSeed)) printMatrix m = assocs m -- Path with first city in path appended to end. wrappedPath :: [Int] -> [Int] wrappedPath path = ((tail path) ++ [(head path)]) pathLength :: Array (Int,Int) Double -> [Int] -> Double pathLength cities path = let f x = cities ! x pairs = zip path (wrappedPath path) in -- sum (GHC.Base.map f pairs) sum (Prelude.map f pairs) -- Boosts pheromones for cities on path. updatePher :: Array (Int,Int) Double -> [Int] -> Array (Int,Int) Double updatePher pher path = let wPath = wrappedPath path pairs = zip path wPath incrs = [ (fromIntegral boost) | n <- wPath ] pairsWithInc = zip pairs incrs in accum (+) pher pairsWithInc evaporatePher :: Array (Int,Int) Double -> Int -> Array (Int,Int) Double evaporatePher pher maxIter = let inds = indices pher decrs = [ ((fromIntegral boost)/(fromIntegral maxIter)) | n <- inds ] indsWithDecr = zip inds decrs f x y = if x > y then (x - y) else 0.0 in accum f pher indsWithDecr -- Sum weights for all paths to cities adjacent to current. doSumWeight :: Int -> Array (Int,Int) Double -> Array (Int,Int) Double -> IntSet -> Int -> Double -> Double doSumWeight city cities pher used current runningTotal = if city >= numCities then runningTotal else let incr = if (member city used) then 0.0 else (cities!(current, city)) * (1.0 + (pher!(current, city))) in doSumWeight (city+1) cities pher used current (runningTotal+incr) -- Returns city at soughtTotal. findSumWeight :: Int -> Int -> Array (Int,Int) Double -> Array (Int,Int) Double -> IntSet -> Int -> Double -> Double -> Int findSumWeight city nextCity cities pher used current soughtTotal runningTotal = if (city >= numCities) || ((not (member city used)) && (runningTotal >= soughtTotal)) then nextCity else let (incr, nextNextCity) = if (member city used) then (0.0, nextCity) else ((cities!(current,city))*(1.0+(pher!(current, city))), city) in findSumWeight (city+1) nextNextCity cities pher used current soughtTotal (runningTotal+incr) -- Returns (path, newrGen) genPathRecurse :: Array (Int,Int) Double -> Array (Int, Int) Double -> IntSet -> [Int] -> Int -> StdGen -> ([Int],StdGen) genPathRecurse cities pher used path current rGen = if (size used) >= numCities then (path, rGen) else let sumWeight = doSumWeight 0 cities pher used current 0.0 (rndValue, newrGen) = randomR (0.0, sumWeight) rGen nextCity = findSumWeight 0 0 cities pher used current rndValue 0.0 nextPath = path ++ [nextCity] nextUsed = insert nextCity used in genPathRecurse cities pher nextUsed nextPath nextCity newrGen -- Returns (path, newrGen) genPath :: Array (Int,Int) Double -> Array (Int, Int) Double -> StdGen -> ([Int], StdGen) genPath cities pher rGen = let (current, newrGen) = randomR (0, numCities-1) rGen used = insert current Set.empty path = [current] in genPathRecurse cities pher used path current newrGen -- Returns path bestPathRecurse :: Array (Int,Int) Double -> Array (Int,Int) Double -> StdGen -> Int -> Int -> [Int] -> Double -> [Int] bestPathRecurse cities pher rGen maxIter remainingIter bestPathSoFar bestLength = if remainingIter <= 0 then bestPathSoFar else let (path, newrGen) = genPath cities pher rGen pathLen = pathLength cities path (newBestPath,newBestLength,newPher) = -- Remember we are trying to maximize score. if pathLen > bestLength then (path, pathLen, (updatePher pher path)) else (bestPathSoFar, bestLength, pher) evaporatedPher = evaporatePher newPher maxIter in bestPathRecurse cities evaporatedPher newrGen maxIter (remainingIter-1) newBestPath newBestLength -- Returns path bestPath :: Array (Int,Int) Double -> Int -> Int -> [Int] bestPath cities rSeed numIter = let rGen = mkStdGen rSeed pher = matrix numCities in bestPathRecurse cities pher rGen numIter numIter [] 0.0 {- Hack to prevent "Occurs check: cannot construct the infinit type bx = Array (Int, Int) Double -> StdGen -> Int -> bx " error in parallelBestPath, below. -} -- Returns path wrapBestPath :: Array (Int,Int) Double -> Int -> Int -> [Int] wrapBestPath cities rSeed numIter = bestPath cities rSeed numIter -- returns (path, length) parallelBestPath :: Array (Int,Int) Double -> Int -> ([Int], Double) parallelBestPath cities iter = let -- 'par' says spark new thread for p1 -- 'seq' says start p2 now also (path1, path2) = par p1 (seq p2 (p1, p2)) where p1 = wrapBestPath cities 1 iter p2 = wrapBestPath cities 2 iter len1 = pathLength cities path1 len2 = pathLength cities path2 (bestPath, bestLen) = if len1 > len2 then (path1,len1) else (path2,len2) in (bestPath, bestLen) -- returns (path, length) parallelBestPathStrategy :: Array (Int,Int) Double -> Int -> ([Int], Double) parallelBestPathStrategy cities iter = let f rSeed = wrapBestPath cities rSeed iter -- parMap applies f to each list element in parallel. paths = parMap rwhnf f [1,2] (path1, path2) = (paths !! 0, paths !! 1) len1 = pathLength cities path1 len2 = pathLength cities path2 (bestPath, bestLen) = if len1 > len2 then (path1,len1) else (path2,len2) in (bestPath, bestLen) -- usage: seed iter main = do myargs <- System.Environment.getArgs let seed = (read (myargs !! 0)) :: Int let iter = (read (myargs !! 1)) :: Int let cities = randomMatrix numCities 100.0 seed let (path, len) = parallelBestPathStrategy cities iter putStr (show path) putStr " : " putStrLn (show len)